;;
;; Author: Per Abrahamsen <abraham@dina.kvl.dk>
;; Keywords: help, faces
-;; Version: 1.9924
+;; Version: 1.9929
;; X-URL: http://www.dina.kvl.dk/~abraham/custom/
;; This file is part of GNU Emacs.
(require 'cus-start)
(error nil))
-(define-widget-keywords :custom-category :custom-prefixes :custom-menu
+(define-widget-keywords :custom-last :custom-prefix :custom-category
+ :custom-prefixes :custom-menu
:custom-show
:custom-magic :custom-state :custom-level :custom-form
:custom-set :custom-save :custom-reset-current :custom-reset-saved
;;; Utilities.
+(defun custom-last (x &optional n)
+ ;; Stolen from `cl.el'.
+ "Returns the last link in the list LIST.
+With optional argument N, returns Nth-to-last link (default 1)."
+ (if n
+ (let ((m 0) (p x))
+ (while (consp p) (incf m) (pop p))
+ (if (<= n 0) p
+ (if (< n m) (nthcdr (- m n) x) x)))
+ (while (consp (cdr x)) (pop x))
+ x))
+
(defun custom-quote (sexp)
"Quote SEXP iff it is not self quoting."
(if (or (memq sexp '(t nil))
;;; Sorting.
-(defcustom custom-buffer-sort-predicate 'ignore
- "Function used for sorting group members in buffers.
-The value should be useful as a predicate for `sort'.
-The list to be sorted is the value of the groups `custom-group' property."
- :type '(radio (const :tag "Unsorted" ignore)
- (const :tag "Alphabetic" custom-sort-items-alphabetically)
- (function :tag "Other"))
+(defcustom custom-buffer-sort-alphabetically nil
+ "If non-nil, sort the members of each customization group alphabetically."
+ :type 'boolean
:group 'custom-buffer)
-(defcustom custom-buffer-order-predicate 'custom-sort-groups-last
- "Function used for sorting group members in buffers.
-The value should be useful as a predicate for `sort'.
-The list to be sorted is the value of the groups `custom-group' property."
- :type '(radio (const :tag "Groups first" custom-sort-groups-first)
- (const :tag "Groups last" custom-sort-groups-last)
- (function :tag "Other"))
+(defcustom custom-buffer-groups-last nil
+ "If non-nil, put subgroups after all ordinary options within a group."
+ :type 'boolean
:group 'custom-buffer)
-(defcustom custom-menu-sort-predicate 'ignore
- "Function used for sorting group members in menus.
-The value should be useful as a predicate for `sort'.
-The list to be sorted is the value of the groups `custom-group' property."
- :type '(radio (const :tag "Unsorted" ignore)
- (const :tag "Alphabetic" custom-sort-items-alphabetically)
- (function :tag "Other"))
+(defcustom custom-menu-sort-alphabetically nil
+ "If non-nil, sort the members of each customization group alphabetically."
+ :type 'boolean
:group 'custom-menu)
-(defcustom custom-menu-order-predicate 'custom-sort-groups-first
- "Function used for sorting group members in menus.
-The value should be useful as a predicate for `sort'.
-The list to be sorted is the value of the groups `custom-group' property."
- :type '(radio (const :tag "Groups first" custom-sort-groups-first)
- (const :tag "Groups last" custom-sort-groups-last)
- (function :tag "Other"))
+(defcustom custom-menu-groups-first t
+ "If non-nil, put subgroups before all ordinary options within a group."
+ :type 'boolean
:group 'custom-menu)
-(defun custom-sort-items-alphabetically (a b)
- "Return t iff A is alphabetically before B and the same custom type.
+(defun custom-buffer-sort-predicate (a b)
+ "Return t iff A should come before B in a customization buffer.
A and B should be members of a `custom-group' property."
- (and (eq (nth 1 a) (nth 1 b))
- (string-lessp (symbol-name (nth 0 a)) (symbol-name (nth 0 b)))))
+ (cond ((and (not custom-buffer-groups-last)
+ (not custom-buffer-sort-alphabetically))
+ nil)
+ ((or (eq (eq (nth 1 a) 'custom-group) (eq (nth 1 b) 'custom-group))
+ (not custom-buffer-groups-last))
+ (if custom-buffer-sort-alphabetically
+ (string-lessp (symbol-name (nth 0 a)) (symbol-name (nth 0 b)))
+ nil))
+ (t
+ (not (eq (nth 1 a) 'custom-group) ))))
-(defun custom-sort-groups-first (a b)
- "Return t iff A a custom group and B is a not.
-A and B should be members of a `custom-group' property."
- (and (eq (nth 1 a) 'custom-group)
- (not (eq (nth 1 b) 'custom-group))))
+(defalias 'custom-browse-sort-predicate 'ignore)
-(defun custom-sort-groups-last (a b)
- "Return t iff B a custom group and A is a not.
+(defun custom-menu-sort-predicate (a b)
+ "Return t iff A should come before B in a customization menu.
A and B should be members of a `custom-group' property."
- (and (eq (nth 1 b) 'custom-group)
- (not (eq (nth 1 a) 'custom-group))))
+ (cond ((and (not custom-menu-groups-first)
+ (not custom-menu-sort-alphabetically))
+ nil)
+ ((or (eq (eq (nth 1 a) 'custom-group) (eq (nth 1 b) 'custom-group))
+ (not custom-menu-groups-first))
+ (if custom-menu-sort-alphabetically
+ (string-lessp (symbol-name (nth 0 a)) (symbol-name (nth 0 b)))
+ nil))
+ (t
+ (eq (nth 1 a) 'custom-group) )))
;;; Custom Mode Commands.
(push (list symbol 'custom-variable) found)))))
(if (not found)
(error "No matches")
- (custom-buffer-create (sort (sort found
- ;; Apropos should always be sorted.
- 'custom-sort-items-alphabetically)
- custom-buffer-order-predicate)
- "*Customize Apropos*"))))
+ (let ((custom-buffer-sort-alphabetically t))
+ (custom-buffer-create (sort found 'custom-buffer-sort-predicate)
+ "*Customize Apropos*")))))
;;;###autoload
(defun customize-apropos-options (regexp &optional arg)
;;; Buffer.
+(defcustom custom-buffer-style 'links
+ "Control the presentation style for customization buffers.
+The value should be a symbol, one of:
+
+brackets: groups nest within each other with big horizontal brackets.
+links: groups have links to subgroups."
+ :type '(radio (const brackets)
+ (const links))
+ :group 'custom-buffer)
+
+(defcustom custom-buffer-indent 3
+ "Number of spaces to indent nested groups."
+ :type 'integer
+ :group 'custom-buffer)
+
;;;###autoload
(defun custom-buffer-create (options &optional name)
"Create a buffer containing OPTIONS.
options))))
(unless (eq (preceding-char) ?\n)
(widget-insert "\n"))
- (when (= (length options) 1)
- (message "Creating parent links...")
- (let* ((entry (nth 0 options))
- (name (nth 0 entry))
- (type (nth 1 entry))
- parents)
- (mapatoms (lambda (symbol)
- (let ((group (get symbol 'custom-group)))
- (when (assq name group)
- (when (eq type (nth 1 (assq name group)))
- (push symbol parents))))))
- (when parents
- (goto-char (point-min))
- (search-forward "[Set]")
- (forward-line 1)
- (widget-insert "\nParent groups:")
- (mapcar (lambda (group)
- (widget-insert " ")
- (widget-create 'link
- :tag (custom-unlispify-tag-name group)
- :help-echo (format "\
-Create customize buffer for `%S' group." group)
- :action (lambda (widget &rest ignore)
- (customize-group
- (widget-value widget)))
- group))
- parents)
- (widget-insert "\n"))))
- (message "Creating customization magic...")
- (mapcar 'custom-magic-reset custom-options)
+ (unless (eq custom-buffer-style 'tree)
+ (mapcar 'custom-magic-reset custom-options))
(message "Creating customization setup...")
(widget-setup)
(goto-char (point-min))
(message "Creating customization buffer...done"))
+;;; The Tree Browser.
+
+;;;###autoload
+(defun customize-browse ()
+ "Create a tree browser for the customize hierarchy."
+ (interactive)
+ (let ((name "*Customize Browser*"))
+ (kill-buffer (get-buffer-create name))
+ (switch-to-buffer (get-buffer-create name)))
+ (custom-mode)
+ (widget-insert "\
+Invoke [+] below to expand items, and [-] to collapse items.
+Invoke the [group], [face], and [option] buttons below to edit that
+item in another window.\n\n")
+ (let ((custom-buffer-style 'tree))
+ (widget-create 'custom-group
+ :custom-last t
+ :custom-state 'unknown
+ :tag (custom-unlispify-tag-name 'emacs)
+ :value 'emacs))
+ (goto-char (point-min)))
+
+(define-widget 'custom-tree-visibility 'item
+ "Control visibility of of items in the customize tree browser."
+ :button-prefix "["
+ :button-suffix "]"
+ :format "%[%t%]"
+ :action 'custom-tree-visibility-action)
+
+(defun custom-tree-visibility-action (widget &rest ignore)
+ (let ((custom-buffer-style 'tree))
+ (custom-toggle-parent widget)))
+
+(define-widget 'custom-tree-group-tag 'push-button
+ "Show parent in other window when activated."
+ :tag "group"
+ :action 'custom-tree-group-tag-action)
+
+(defun custom-tree-group-tag-action (widget &rest ignore)
+ (let ((parent (widget-get widget :parent)))
+ (customize-group-other-window (widget-value parent))))
+
+(define-widget 'custom-tree-variable-tag 'push-button
+ "Show parent in other window when activated."
+ :tag "option"
+ :action 'custom-tree-variable-tag-action)
+
+(defun custom-tree-variable-tag-action (widget &rest ignore)
+ (let ((parent (widget-get widget :parent)))
+ (customize-variable-other-window (widget-value parent))))
+
+(define-widget 'custom-tree-face-tag 'push-button
+ "Show parent in other window when activated."
+ :tag "face"
+ :action 'custom-tree-face-tag-action)
+
+(defun custom-tree-face-tag-action (widget &rest ignore)
+ (let ((parent (widget-get widget :parent)))
+ (customize-face-other-window (widget-value parent))))
+
;;; Modification of Basic Widgets.
;;
;; We add extra properties to the basic widgets needed here. This is
(memq category custom-magic-show-hidden)))
(insert " ")
(when (eq category 'group)
- (insert-char ?\ (1+ (* 2 (widget-get parent :custom-level)))))
+ (insert-char ?\ (* custom-buffer-indent
+ (widget-get parent :custom-level))))
(push (widget-create-child-and-convert
widget 'choice-item
:help-echo "Change the state of this item."
(when lisp
(insert " (lisp)"))
(insert "\n"))
+ (when (eq category 'group)
+ (insert-char ?\ (* custom-buffer-indent
+ (widget-get parent :custom-level))))
(when custom-magic-show-button
(when custom-magic-show
(let ((indent (widget-get parent :indent)))
(define-widget 'custom 'default
"Customize a user option."
+ :format "%v"
:convert-widget 'custom-convert-widget
- :format-handler 'custom-format-handler
:notify 'custom-notify
+ :custom-prefix ""
:custom-level 1
:custom-state 'hidden
:documentation-property 'widget-subclass-responsibility
:validate 'widget-children-validate
:match (lambda (widget value) (symbolp value)))
-(defcustom custom-nest-groups nil
- "*Non-nil means display nested groups in one customization buffer.
-A valoe of nil means show a subgroup in its own buffer
-rather than including it within its parent's customization buffer."
- :type 'boolean
- :group 'custom-buffer)
-
(defun custom-convert-widget (widget)
;; Initialize :value and :tag from :args in WIDGET.
(let ((args (widget-get widget :args)))
(widget-put widget :args nil)))
widget)
-(defun custom-format-handler (widget escape)
- ;; We recognize extra escape sequences.
- (let* ((buttons (widget-get widget :buttons))
- (state (widget-get widget :custom-state))
- (level (widget-get widget :custom-level))
- (category (widget-get widget :custom-category)))
- (cond ((eq escape ?l)
- (if custom-nest-groups
- (when level
- (insert-char ?\ (* 3 (1- level)))
- (if (eq state 'hidden)
- (insert "-- ")
- (insert "/- ")))
- (unless (and level (> level 1))
- (insert "/- "))))
- ((eq escape ?e)
- (when (and level (not (eq state 'hidden)))
- (insert "\n")
- (if custom-nest-groups
- (insert-char ?\ (* 3 (1- level))))
- (insert "\\-")
- (insert " " (widget-get widget :tag) " group end ")
- (insert-char ?- (- 75 (current-column) level))
- (insert "/\n")))
- ((eq escape ?-)
- (when (and level (not (eq state 'hidden)))
- ;; Add 1 to compensate for the extra < character
- ;; at the beginning of the line.
- (insert-char ?- (- (+ 75 1) (current-column) level))
- (insert "\\")))
- ((eq escape ?i)
- (if custom-nest-groups
- (insert-char ?\ (* 3 level))
- (unless (and level (> level 1))
- (insert " "))))
- ((eq escape ?L)
- (if custom-nest-groups
- (push (widget-create-child-and-convert
- widget 'group-visibility
- :help-echo "Show or hide this group."
- :action 'custom-toggle-parent
- (not (eq state 'hidden)))
- buttons)
- (push (widget-create-child-and-convert
- widget 'group-link
- :help-echo "Select the contents of this group."
- :value (widget-get widget :value)
- :tag "Switch to Group"
- (not (eq state 'hidden)))
- buttons)))
- ((eq escape ?m)
- (and (eq (preceding-char) ?\n)
- (widget-get widget :indent)
- (insert-char ? (widget-get widget :indent)))
- (let ((magic (widget-create-child-and-convert
- widget 'custom-magic nil)))
- (widget-put widget :custom-magic magic)
- (push magic buttons)
- (widget-put widget :buttons buttons)))
- ((eq escape ?a)
- (unless (eq state 'hidden)
- (let* ((symbol (widget-get widget :value))
- (links (get symbol 'custom-links))
- (many (> (length links) 2)))
- (when links
- (and (eq (preceding-char) ?\n)
- (widget-get widget :indent)
- (insert-char ? (widget-get widget :indent)))
- (when (eq category 'group)
- (insert-char ?\ (1+ (* 2 level))))
- (insert "See also ")
- (while links
- (push (widget-create-child-and-convert widget (car links))
- buttons)
- (setq links (cdr links))
- (cond ((null links)
- (insert ".\n"))
- ((null (cdr links))
- (if many
- (insert ", and ")
- (insert " and ")))
- (t
- (insert ", "))))
- (widget-put widget :buttons buttons)))))
- (t
- (widget-default-format-handler widget escape)))))
-
(defun custom-notify (widget &rest args)
"Keep track of changes."
(let ((state (widget-get widget :custom-state)))
"Redraw WIDGET state with current settings."
(while widget
(let ((magic (widget-get widget :custom-magic)))
- (unless magic
- (debug))
- (widget-value-set magic (widget-value magic))
- (when (setq widget (widget-get widget :group))
- (custom-group-state-update widget))))
+ (cond (magic
+ (widget-value-set magic (widget-value magic))
+ (when (setq widget (widget-get widget :group))
+ (custom-group-state-update widget)))
+ (t
+ (setq widget nil)))))
(widget-setup))
(defun custom-show (widget value)
"Toggle visibility of parent to WIDGET."
(custom-toggle-hide (widget-get widget :parent)))
+(defun custom-add-see-also (widget &optional prefix)
+ "Add `See also ...' to WIDGET if there are any links.
+Insert PREFIX first if non-nil."
+ (let* ((symbol (widget-get widget :value))
+ (links (get symbol 'custom-links))
+ (many (> (length links) 2))
+ (buttons (widget-get widget :buttons))
+ (indent (widget-get widget :indent)))
+ (when links
+ (when indent
+ (insert-char ?\ indent))
+ (when prefix
+ (insert prefix))
+ (insert "See also ")
+ (while links
+ (push (widget-create-child-and-convert widget (car links))
+ buttons)
+ (setq links (cdr links))
+ (cond ((null links)
+ (insert ".\n"))
+ ((null (cdr links))
+ (if many
+ (insert ", and ")
+ (insert " and ")))
+ (t
+ (insert ", "))))
+ (widget-put widget :buttons buttons))))
+
+(defun custom-add-parent-links (widget)
+ "Add `Parent groups: ...' to WIDGET."
+ (let ((name (widget-value widget))
+ (type (widget-type widget))
+ (buttons (widget-get widget :buttons))
+ found)
+ (insert "Parent groups:")
+ (mapatoms (lambda (symbol)
+ (let ((group (get symbol 'custom-group)))
+ (when (assq name group)
+ (when (eq type (nth 1 (assq name group)))
+ (insert " ")
+ (push (widget-create-child-and-convert
+ widget 'custom-group-link
+ :tag (custom-unlispify-tag-name symbol)
+ symbol)
+ buttons)
+ (setq found t))))))
+ (widget-put widget :buttons buttons)
+ (unless found
+ (insert " (none)"))
+ (insert "\n")))
+
;;; The `custom-variable' Widget.
(defface custom-variable-sample-face '((t (:underline t)))
(define-widget 'custom-variable 'custom
"Customize variable."
- :format "%v%m%h%a"
+ :format "%v"
:help-echo "Set or reset this variable."
:documentation-property 'variable-documentation
:custom-category 'option
(type (custom-variable-type symbol))
(conv (widget-convert type))
(get (or (get symbol 'custom-get) 'default-value))
+ (prefix (widget-get widget :custom-prefix))
+ (last (widget-get widget :custom-last))
(value (if (default-boundp symbol)
(funcall get symbol)
(widget-get conv :value))))
;; (widget-apply (widget-convert type) :match value)
(setq form 'lisp)))
;; Now we can create the child widget.
- (cond ((eq state 'hidden)
+ (cond ((eq custom-buffer-style 'tree)
+ (insert prefix (if last " +--- " " |--- "))
+ (push (widget-create-child-and-convert
+ widget 'custom-tree-variable-tag)
+ buttons)
+ (insert " " tag "\n")
+ (widget-put widget :buttons buttons))
+ ((eq state 'hidden)
;; Indicate hidden value.
(push (widget-create-child-and-convert
widget 'item
(custom-quote (widget-get conv :value))))))
(insert (symbol-name symbol) ": ")
(push (widget-create-child-and-convert
- widget 'visibility
- :help-echo "Hide the value of this option."
- :action 'custom-toggle-parent
- t)
- buttons)
+ widget 'visibility
+ :help-echo "Hide the value of this option."
+ :action 'custom-toggle-parent
+ t)
+ buttons)
(insert " ")
(push (widget-create-child-and-convert
widget 'sexp
:format value-format
:value value)
children))))
- ;; Now update the state.
- (unless (eq (preceding-char) ?\n)
- (widget-insert "\n"))
- (if (eq state 'hidden)
- (widget-put widget :custom-state state)
- (custom-variable-state-set widget))
- (widget-put widget :custom-form form)
- (widget-put widget :buttons buttons)
- (widget-put widget :children children)))
+ (unless (eq custom-buffer-style 'tree)
+ ;; Now update the state.
+ (unless (eq (preceding-char) ?\n)
+ (widget-insert "\n"))
+ (if (eq state 'hidden)
+ (widget-put widget :custom-state state)
+ (custom-variable-state-set widget))
+ ;; Create the magic button.
+ (let ((magic (widget-create-child-and-convert
+ widget 'custom-magic nil)))
+ (widget-put widget :custom-magic magic)
+ (push magic buttons))
+ ;; Update properties.
+ (widget-put widget :custom-form form)
+ (widget-put widget :buttons buttons)
+ (widget-put widget :children children)
+ ;; Insert documentation.
+ (widget-default-format-handler widget ?h)
+ ;; See also.
+ (unless (eq state 'hidden)
+ (when (eq (widget-get widget :custom-level) 1)
+ (custom-add-parent-links widget))
+ (custom-add-see-also widget)))))
(defun custom-tag-action (widget &rest args)
"Pass :action to first child of WIDGET's parent."
(define-widget 'custom-face 'custom
"Customize face."
- :format "%{%t%}: %s %L\n%m%h%a%v"
- :format-handler 'custom-face-format-handler
:sample-face 'custom-face-tag-face
:help-echo "Set or reset this face."
:documentation-property '(lambda (face)
:custom-reset-standard 'custom-face-reset-standard
:custom-menu 'custom-face-menu-create)
-(defun custom-face-format-handler (widget escape)
- ;; We recognize extra escape sequences.
- (let (child
- (symbol (widget-get widget :value)))
- (cond ((eq escape ?s)
- (and (string-match "XEmacs" emacs-version)
- ;; XEmacs cannot display initialized faces.
- (not (custom-facep symbol))
- (copy-face 'custom-face-empty symbol))
- (setq child (widget-create-child-and-convert
- widget 'item
- :format "(%{%t%})"
- :sample-face symbol
- :tag "sample")))
- (t
- (custom-format-handler widget escape)))
- (when child
- (widget-put widget
- :buttons (cons child (widget-get widget :buttons))))))
-
(define-widget 'custom-face-all 'editable-list
"An editable list of display specifications and attributes."
:entry-format "%i %d %v"
"Converted version of the `custom-face-selected' widget.")
(defun custom-face-value-create (widget)
- ;; Create a list of the display specifications.
- (unless (eq (preceding-char) ?\n)
- (insert "\n"))
- (when (not (eq (widget-get widget :custom-state) 'hidden))
- (message "Creating face editor...")
- (custom-load-widget widget)
- (let* ((symbol (widget-value widget))
- (spec (or (get symbol 'saved-face)
- (get symbol 'face-defface-spec)
- ;; Attempt to construct it.
- (list (list t (custom-face-attributes-get
- symbol (selected-frame))))))
- (form (widget-get widget :custom-form))
- (indent (widget-get widget :indent))
- (edit (widget-create-child-and-convert
- widget
- (cond ((and (eq form 'selected)
- (widget-apply custom-face-selected :match spec))
- (when indent (insert-char ?\ indent))
- 'custom-face-selected)
- ((and (not (eq form 'lisp))
- (widget-apply custom-face-all :match spec))
- 'custom-face-all)
- (t
- (when indent (insert-char ?\ indent))
- 'sexp))
- :value spec)))
- (custom-face-state-set widget)
- (widget-put widget :children (list edit)))
- (message "Creating face editor...done")))
+ "Create a list of the display specifications for WIDGET."
+ (let ((buttons (widget-get widget :buttons))
+ (symbol (widget-get widget :value))
+ (tag (widget-get widget :tag))
+ (state (widget-get widget :custom-state))
+ (begin (point))
+ (is-last (widget-get widget :custom-last))
+ (prefix (widget-get widget :custom-prefix)))
+ (unless tag
+ (setq tag (prin1-to-string symbol)))
+ (cond ((eq custom-buffer-style 'tree)
+ (insert prefix (if is-last " +--- " " |--- "))
+ (push (widget-create-child-and-convert
+ widget 'custom-tree-face-tag)
+ buttons)
+ (insert " " tag "\n")
+ (widget-put widget :buttons buttons))
+ (t
+ ;; Create tag.
+ (insert tag)
+ (if (eq custom-buffer-style 'face)
+ (insert " ")
+ (widget-specify-sample widget begin (point))
+ (insert ": "))
+ ;; Sample.
+ (and (string-match "XEmacs" emacs-version)
+ ;; XEmacs cannot display uninitialized faces.
+ (not (custom-facep symbol))
+ (copy-face 'custom-face-empty symbol))
+ (push (widget-create-child-and-convert widget 'item
+ :format "(%{%t%})"
+ :sample-face symbol
+ :tag "sample")
+ buttons)
+ ;; Visibility.
+ (insert " ")
+ (push (widget-create-child-and-convert
+ widget 'visibility
+ :help-echo "Hide or show this face."
+ :action 'custom-toggle-parent
+ (not (eq state 'hidden)))
+ buttons)
+ ;; Magic.
+ (insert "\n")
+ (let ((magic (widget-create-child-and-convert
+ widget 'custom-magic nil)))
+ (widget-put widget :custom-magic magic)
+ (push magic buttons))
+ ;; Update buttons.
+ (widget-put widget :buttons buttons)
+ ;; Insert documentation.
+ (widget-default-format-handler widget ?h)
+ ;; See also.
+ (unless (eq state 'hidden)
+ (when (eq (widget-get widget :custom-level) 1)
+ (custom-add-parent-links widget))
+ (custom-add-see-also widget))
+ ;; Editor.
+ (unless (eq (preceding-char) ?\n)
+ (insert "\n"))
+ (unless (eq state 'hidden)
+ (message "Creating face editor...")
+ (custom-load-widget widget)
+ (let* ((symbol (widget-value widget))
+ (spec (or (get symbol 'saved-face)
+ (get symbol 'face-defface-spec)
+ ;; Attempt to construct it.
+ (list (list t (custom-face-attributes-get
+ symbol (selected-frame))))))
+ (form (widget-get widget :custom-form))
+ (indent (widget-get widget :indent))
+ (edit (widget-create-child-and-convert
+ widget
+ (cond ((and (eq form 'selected)
+ (widget-apply custom-face-selected
+ :match spec))
+ (when indent (insert-char ?\ indent))
+ 'custom-face-selected)
+ ((and (not (eq form 'lisp))
+ (widget-apply custom-face-all
+ :match spec))
+ 'custom-face-all)
+ (t
+ (when indent (insert-char ?\ indent))
+ 'sexp))
+ :value spec)))
+ (custom-face-state-set widget)
+ (widget-put widget :children (list edit)))
+ (message "Creating face editor...done"))))))
(defvar custom-face-menu
'(("Set" custom-face-set)
(define-widget 'face 'default
"Select and customize a face."
:convert-widget 'widget-value-convert-widget
- :format "%[%t%]: %v"
+ :button-prefix 'widget-push-button-prefix
+ :button-suffix 'widget-push-button-suffix
+ :format "%t: %[select face%] %v"
:tag "Face"
:value 'default
:value-create 'widget-face-value-create
(defun widget-face-value-create (widget)
;; Create a `custom-face' child.
(let* ((symbol (widget-value widget))
+ (custom-buffer-style 'face)
(child (widget-create-child-and-convert
widget 'custom-face
- :format "%t %s %L\n%m%h%v"
:custom-level nil
:value symbol)))
(custom-magic-reset child)
(widget-put widget :args args)
widget))
+;;; The `custom-group-link' Widget.
+
+(define-widget 'custom-group-link 'link
+ "Show parent in other window when activated."
+ :help-echo "Create customize buffer for this group group."
+ :action 'custom-group-link-action)
+
+(defun custom-group-link-action (widget &rest ignore)
+ (customize-group (widget-value widget)))
+
;;; The `custom-group' Widget.
(defcustom custom-group-tag-faces '(custom-group-tag-face-1)
(define-widget 'custom-group 'custom
"Customize group."
- :format "%l%{%t%} group: %L %-\n%m%i%h%a%v%e"
+ :format "%v"
:sample-face-get 'custom-group-sample-face-get
:documentation-property 'group-documentation
:help-echo "Set or reset all members of this group."
'custom-group-tag-face))
(defun custom-group-value-create (widget)
- (let ((state (widget-get widget :custom-state)))
- (unless (eq state 'hidden)
- (message "Creating group...")
- (custom-load-widget widget)
- (let* ((level (widget-get widget :custom-level))
- (symbol (widget-value widget))
- (members (sort (sort (copy-sequence (get symbol 'custom-group))
- custom-buffer-sort-predicate)
- custom-buffer-order-predicate))
- (prefixes (widget-get widget :custom-prefixes))
- (custom-prefix-list (custom-prefix-add symbol prefixes))
- (length (length members))
- (count 0)
- (children (mapcar (lambda (entry)
- (widget-insert "\n")
- (message "Creating group members... %2d%%"
- (/ (* 100.0 count) length))
- (setq count (1+ count))
- (prog1
- (widget-create-child-and-convert
- widget (nth 1 entry)
- :group widget
- :tag (custom-unlispify-tag-name
- (nth 0 entry))
- :custom-prefixes custom-prefix-list
- :custom-level (1+ level)
- :value (nth 0 entry))
- (unless (eq (preceding-char) ?\n)
- (widget-insert "\n"))))
- members)))
- (message "Creating group magic...")
- (mapcar 'custom-magic-reset children)
- (message "Creating group state...")
- (widget-put widget :children children)
- (custom-group-state-update widget)
- (message "Creating group... done")))))
+ "Insert a customize group for WIDGET in the current buffer."
+ (let ((state (widget-get widget :custom-state))
+ (level (widget-get widget :custom-level))
+ (indent (widget-get widget :indent))
+ (prefix (widget-get widget :custom-prefix))
+ (buttons (widget-get widget :buttons))
+ (tag (widget-get widget :tag))
+ (symbol (widget-value widget)))
+ (cond ((and (eq custom-buffer-style 'tree)
+ (eq state 'hidden))
+ (insert prefix)
+ (push (widget-create-child-and-convert
+ widget 'custom-tree-visibility :tag "+")
+ buttons)
+ (insert "-- ")
+ (push (widget-create-child-and-convert
+ widget 'custom-tree-group-tag)
+ buttons)
+ (insert " " tag "\n")
+ (widget-put widget :buttons buttons))
+ ((and (eq custom-buffer-style 'tree)
+ (zerop (length (get symbol 'custom-group))))
+ (insert prefix "[ ]-- ")
+ (push (widget-create-child-and-convert
+ widget 'custom-tree-group-tag)
+ buttons)
+ (insert " " tag "\n")
+ (widget-put widget :buttons buttons))
+ ((eq custom-buffer-style 'tree)
+ (insert prefix)
+ (custom-load-widget widget)
+ (if (zerop (length (get symbol 'custom-group)))
+ (progn
+ (insert prefix "[ ]-- ")
+ (push (widget-create-child-and-convert
+ widget 'custom-tree-group-tag)
+ buttons)
+ (insert " " tag "\n")
+ (widget-put widget :buttons buttons))
+ (push (widget-create-child-and-convert
+ widget 'custom-tree-visibility :tag "-")
+ buttons)
+ (insert "-+ ")
+ (push (widget-create-child-and-convert
+ widget 'custom-tree-group-tag)
+ buttons)
+ (insert " " tag "\n")
+ (widget-put widget :buttons buttons)
+ (message "Creating group...")
+ (let* ((members (sort (copy-sequence (get symbol 'custom-group))
+ 'custom-browse-sort-predicate))
+ (prefixes (widget-get widget :custom-prefixes))
+ (custom-prefix-list (custom-prefix-add symbol prefixes))
+ (length (length members))
+ (extra-prefix (if (widget-get widget :custom-last)
+ " "
+ " | "))
+ (prefix (concat prefix extra-prefix))
+ children entry)
+ (while members
+ (setq entry (car members)
+ members (cdr members))
+ (push (widget-create-child-and-convert
+ widget (nth 1 entry)
+ :group widget
+ :tag (custom-unlispify-tag-name
+ (nth 0 entry))
+ :custom-prefixes custom-prefix-list
+ :custom-level (1+ level)
+ :custom-last (null members)
+ :value (nth 0 entry)
+ :custom-prefix prefix)
+ children))
+ (widget-put widget :children (reverse children)))
+ (message "Creating group...done")))
+ ;; Nested style.
+ ((eq state 'hidden)
+ ;; Create level indicator.
+ (insert-char ?\ (* custom-buffer-indent (1- level)))
+ (insert "-- ")
+ ;; Create tag.
+ (let ((begin (point)))
+ (insert tag)
+ (widget-specify-sample widget begin (point)))
+ (insert " group: ")
+ ;; Create link/visibility indicator.
+ (if (eq custom-buffer-style 'links)
+ (push (widget-create-child-and-convert
+ widget 'custom-group-link
+ :tag "Show"
+ symbol)
+ buttons)
+ (push (widget-create-child-and-convert
+ widget 'visibility
+ :help-echo "Show members of this group."
+ :action 'custom-toggle-parent
+ (not (eq state 'hidden)))
+ buttons))
+ (insert " \n")
+ ;; Create magic button.
+ (let ((magic (widget-create-child-and-convert
+ widget 'custom-magic nil)))
+ (widget-put widget :custom-magic magic)
+ (push magic buttons))
+ ;; Update buttons.
+ (widget-put widget :buttons buttons)
+ ;; Insert documentation.
+ (widget-default-format-handler widget ?h))
+ ;; Nested style.
+ (t ;Visible.
+ ;; Create level indicator.
+ (insert-char ?\ (* custom-buffer-indent (1- level)))
+ (insert "/- ")
+ ;; Create tag.
+ (let ((start (point)))
+ (insert tag)
+ (widget-specify-sample widget start (point)))
+ (insert " group: ")
+ ;; Create visibility indicator.
+ (unless (eq custom-buffer-style 'links)
+ (insert "--------")
+ (push (widget-create-child-and-convert
+ widget 'visibility
+ :help-echo "Hide members of this group."
+ :action 'custom-toggle-parent
+ (not (eq state 'hidden)))
+ buttons)
+ (insert " "))
+ ;; Create more dashes.
+ ;; Use 76 instead of 75 to compensate for the temporary "<"
+ ;; added by `widget-insert'.
+ (insert-char ?- (- 76 (current-column)
+ (* custom-buffer-indent level)))
+ (insert "\\\n")
+ ;; Create magic button.
+ (let ((magic (widget-create-child-and-convert
+ widget 'custom-magic
+ :indent 0
+ nil)))
+ (widget-put widget :custom-magic magic)
+ (push magic buttons))
+ ;; Update buttons.
+ (widget-put widget :buttons buttons)
+ ;; Insert documentation.
+ (widget-default-format-handler widget ?h)
+ ;; Parents and See also.
+ (when (eq level 1)
+ (insert-char ?\ custom-buffer-indent)
+ (custom-add-parent-links widget))
+ (custom-add-see-also widget
+ (make-string (* custom-buffer-indent level)
+ ?\ ))
+ ;; Members.
+ (message "Creating group...")
+ (custom-load-widget widget)
+ (let* ((members (sort (copy-sequence (get symbol 'custom-group))
+ 'custom-buffer-sort-predicate))
+ (prefixes (widget-get widget :custom-prefixes))
+ (custom-prefix-list (custom-prefix-add symbol prefixes))
+ (length (length members))
+ (count 0)
+ (children (mapcar (lambda (entry)
+ (widget-insert "\n")
+ (message "\
+Creating group members... %2d%%"
+ (/ (* 100.0 count) length))
+ (setq count (1+ count))
+ (prog1
+ (widget-create-child-and-convert
+ widget (nth 1 entry)
+ :group widget
+ :tag (custom-unlispify-tag-name
+ (nth 0 entry))
+ :custom-prefixes custom-prefix-list
+ :custom-level (1+ level)
+ :value (nth 0 entry))
+ (unless (eq (preceding-char) ?\n)
+ (widget-insert "\n"))))
+ members)))
+ (message "Creating group magic...")
+ (mapcar 'custom-magic-reset children)
+ (message "Creating group state...")
+ (widget-put widget :children children)
+ (custom-group-state-update widget)
+ (message "Creating group... done"))
+ ;; End line
+ (insert "\n")
+ (insert-char ?\ (* custom-buffer-indent (1- level)))
+ (insert "\\- " (widget-get widget :tag) " group end ")
+ (insert-char ?- (- 75 (current-column) (* custom-buffer-indent level)))
+ (insert "/\n")))))
(defvar custom-group-menu
'(("Set" custom-group-set
(< (length (get symbol 'custom-group)) widget-menu-max-size))
(let ((custom-prefix-list (custom-prefix-add symbol
custom-prefix-list))
- (members (sort (sort (copy-sequence (get symbol 'custom-group))
- custom-menu-sort-predicate)
- custom-menu-order-predicate)))
+ (members (sort (copy-sequence (get symbol 'custom-group))
+ 'custom-menu-sort-predicate)))
(custom-load-symbol symbol)
`(,(custom-unlispify-menu-entry symbol t)
,item
;; We can delay it under XEmacs.
`(,name
:filter (lambda (&rest junk)
- (cdr (custom-menu-create ',symbol))))))
+ (cdr (custom-menu-create ',symbol))))
+ ;; But we must create it now under Emacs.
+ (cons name (cdr (custom-menu-create symbol)))))
;;; The Custom Mode.
(suppress-keymap custom-mode-map)
(define-key custom-mode-map "q" 'bury-buffer))
-(defvar custom-mode-customize-menu)
-(let ((menu (customize-menu-create 'customize)))
- ;; In Emacs, this returns nil, so don't make this menu.
- (if menu
- (easy-menu-define custom-mode-customize-menu
- custom-mode-map
- "Menu used to customize customization buffers."
- menu)
- (setq custom-mode-customize-menu nil)))
-
(easy-menu-define custom-mode-menu
custom-mode-map
"Menu used in customization buffers."
`("Custom"
+ ,(customize-menu-create 'customize)
["Set" custom-set t]
["Save" custom-save t]
["Reset to Current" custom-reset-current t]
(setq major-mode 'custom-mode
mode-name "Custom")
(use-local-map custom-mode-map)
- (if custom-mode-customize-menu
- (easy-menu-add custom-mode-customize-menu))
(easy-menu-add custom-mode-menu)
(make-local-variable 'custom-options)
(run-hooks 'custom-mode-hook))
projects / emacs.git / commitdiff